home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / scheme2c.init < prev    next >
Encoding:
Text File  |  1995-01-04  |  8.6 KB  |  292 lines
  1. ;"scheme2c.init" Initialisation for SLIB for Scheme->C on Sun    -*-scheme-*-
  2. ;Copyright 1991, 1992, 1993 Aubrey Jaffer
  3. ;Copyright 1991 David Love
  4. ;
  5. ;Permission to copy this software, to redistribute it, and to use it
  6. ;for any purpose is granted, subject to the following restrictions and
  7. ;understandings.
  8. ;
  9. ;1.  Any copy made of this software must include this copyright notice
  10. ;in full.
  11. ;
  12. ;2.  I have made no warrantee or representation that the operation of
  13. ;this software will be error-free, and I am under no obligation to
  14. ;provide any services, by way of maintenance, update, or otherwise.
  15. ;
  16. ;3.  In conjunction with products arising from the use of this
  17. ;material, there shall be no use of my name in any advertising,
  18. ;promotional, or sales literature without prior written consent in
  19. ;each case.
  20.  
  21. ;;Modified by David Love (d.love@daresbury.ac.uk) 10/12/91
  22. ;; NB this is for the 01nov91 (and, presumably, later ones,
  23. ;; although those may not need the bug fixes done at the end).
  24. ;; Earlier versions definitely aren't rev4 conformant.  Check
  25. ;; `ieee-floating-point' and `system' in *features* for non-Sun un*x
  26. ;; versions and `system' and the vicinity stuff (at least) for
  27. ;; non-un*x versions.
  28.  
  29. ;; Of course, if you make serious use of library functions you'll want
  30. ;; to compile them and  use Scheme->C modules.
  31.  
  32. (define (software-type) 'UNIX)
  33.  
  34. ;;; (scheme-implementation-type) should return the name of the scheme
  35. ;;; implementation loading this file.
  36.  
  37. (define (scheme-implementation-type) 'Scheme->C)
  38.  
  39. ;;; (scheme-implementation-version) should return a string describing
  40. ;;; the version the scheme implementation loading this file.
  41.  
  42. (define (scheme-implementation-version) "?01nov91")
  43.  
  44. (define (implementation-vicinity)
  45.   (case (software-type)
  46.     ((UNIX)    "/usr/local/lib/scheme/")
  47.     ((VMS)    "scheme$src:")
  48.     ((MS-DOS)    "C:\\scheme\\")))
  49.  
  50. ;;; (library-vicinity) should be defined to be the pathname of the
  51. ;;; directory where files of Scheme library functions reside.
  52.  
  53. (define library-vicinity
  54.   (let ((library-path
  55.      (case (software-type)
  56.        ((UNIX) "/usr/local/lib/slib/")
  57.        ((VMS) "lib$scheme:")
  58.        ((MS-DOS) "C:\\SLIB\\")
  59.        (else ""))))
  60.     (lambda () library-path)))
  61.  
  62. ;;; *FEATURES* should be set to a list of symbols describing features
  63. ;;; of this implementation.  See Template.scm for the list of feature
  64. ;;; names.
  65.  
  66. (define *features*
  67.       '(
  68.     source                ;can load scheme source files
  69.                     ;(slib:load-source "filename")
  70. ;    compiled            ;can load compiled files
  71.                     ;(slib:load-compiled "filename")
  72.     rev4-report
  73.     ;; Follows rev4 as far as I can tell, modulo '() being false,
  74.     ;; number syntax (see doc), incomplete tail recursion (see
  75.     ;; docs) and a couple of bugs in some versions -- see below.
  76.     rev3-report            ;conforms to
  77. ;    ieee-p1178            ;conforms to
  78.     ;; ieee conformance is ruled out by '() being false, if
  79.     ;; nothing else.
  80.     rev4-optional-procedures
  81.     rev3-procedures
  82. ;    rev2-procedures
  83.     multiarg/and-
  84.     multiarg-apply
  85.     rationalize
  86.     object-hash
  87.     delay
  88.     promise
  89.     with-file
  90.     transcript
  91.     char-ready?
  92.     ieee-floating-point
  93.     full-continuation
  94.     pretty-print
  95.     format
  96.     trace                ;has macros: TRACE and UNTRACE
  97.     string-port
  98.     system
  99.     ;; next two could be added easily to the interpreter
  100. ;    getenv
  101. ;    program-arguments
  102.     ))
  103.  
  104. (define pretty-print pp)
  105.  
  106. ;;; (OUTPUT-PORT-WIDTH <port>)
  107. (define (output-port-width . arg) 79)
  108.  
  109. ;;; (OUTPUT-PORT-HEIGHT <port>)
  110. (define (output-port-height . arg) 24)
  111.  
  112. ;;; (CURRENT-ERROR-PORT)
  113. (define current-error-port
  114.   (let ((port (current-output-port)))
  115.     (lambda () port)))
  116.  
  117. ;;; (TMPNAM) makes a temporary file name.
  118. (define tmpnam
  119.   (let ((cntr 100))
  120.     (lambda () (set! cntr (+ 1 cntr))
  121.         (let ((tmp (string-append "slib_" (number->string cntr))))
  122.           (if (file-exists? tmp) (tmpnam) tmp)))))
  123.  
  124. ;;; (FILE-EXISTS? <string>)
  125. (define (file-exists? f)
  126.   (case (software-type)
  127.     ((UNIX) (zero? (system (string-append "test -f " f))))
  128.     (else (slib:error "FILE-EXISTS? not defined for " software-type))))
  129.  
  130. ;;; (DELETE-FILE <string>)
  131. (define (delete-file f)
  132.   (case (software-type)
  133.     ((UNIX) (zero? (system (string-append "rm " f))))
  134.     (else (slib:error "DELETE-FILE not defined for " software-type))))
  135.  
  136. ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
  137. ;;; use this definition if your system doesn't have such a procedure.
  138. (define force-output flush-buffer)
  139.  
  140. ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
  141. ;;; port versions of CALL-WITH-*PUT-FILE.
  142. (define (call-with-output-string f)
  143.   (let ((outsp (open-output-string)))
  144.     (f outsp)
  145.     (let ((s (get-output-string outsp)))
  146. ;;;   (close-output-port outsp)        ;doesn't work
  147.       s)))
  148.  
  149. (define (call-with-input-string s f)
  150.   (let* ((insp (open-input-string s))
  151.      (res (f insp)))
  152.     (close-input-port insp)
  153.     res))
  154.  
  155. ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  156. ;;; be returned by CHAR->INTEGER.
  157. (define char-code-limit 256)
  158.  
  159. ;; MOST-POSITIVE-FIXNUM is used in modular.scm
  160. (define most-positive-fixnum 536870911)
  161.  
  162. ;;; Return argument
  163. (define (identity x) x)
  164.  
  165. ;;; If your implementation provides eval, SLIB:EVAL is single argument
  166. ;;; eval using the top-level (user) environment.
  167. (define slib:eval eval)
  168.  
  169. (define-macro defmacro
  170.   (lambda (f e)
  171.     (let ((key (cadr f)) (pattern (caddr f)) (body (cdddr f)))
  172.       (e `(define-macro ,key 
  173.         (let ((%transformer (lambda ,pattern ,@body)))
  174.           (lambda (%form %expr)
  175.         (%expr (apply %transformer (cdr %form)) %expr))))
  176.      e))))
  177.  
  178. (define (defmacro? m) (and (getprop m '*expander*) #t))
  179.  
  180. (define macroexpand-1 expand-once)
  181.  
  182. (define (macroexpand e)
  183.   (if (pair? e) (let ((a (car e)))
  184.           (if (and (symbol? a) (getprop a '*expander*))
  185.               (macroexpand (expand-once e))
  186.               e))
  187.       e))
  188.  
  189. (define gentemp
  190.   (let ((*gensym-counter* -1))
  191.     (lambda ()
  192.       (set! *gensym-counter* (+ *gensym-counter* 1))
  193.       (string->symbol
  194.        (string-append "slib:G" (number->string *gensym-counter*))))))
  195.  
  196. (define defmacro:eval slib:eval)
  197. (define defmacro:load load)
  198. ;;; If your implementation provides R4RS macros:
  199. ;(define macro:eval slib:eval)
  200. ;(define macro:load load)
  201.  
  202. (define (slib:eval-load <pathname> evl)
  203.   (if (not (file-exists? <pathname>))
  204.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  205.   (call-with-input-file <pathname>
  206.     (lambda (port)
  207.       (let ((old-load-pathname *load-pathname*))
  208.     (set! *load-pathname* <pathname>)
  209.     (do ((o (read port) (read port)))
  210.         ((eof-object? o))
  211.       (evl o))
  212.     (set! *load-pathname* old-load-pathname)))))
  213.  
  214. ;; define an error procedure for the library
  215. (define (slib:error . args)
  216.   (error 'slib-error: "~a"
  217.      (apply string-append
  218.         (map
  219.          (lambda (a)
  220.            (format " ~a" a))
  221.          args))))
  222.  
  223. ;; define these as appropriate for your system.
  224. (define slib:tab (integer->char 9))
  225. (define slib:form-feed (integer->char 12))
  226.  
  227. ;;; bug fixes for Scheme->C (versions 28sep90, 23feb90, 01nov91):
  228.  
  229. (let ((vers (substring (cadr (implementation-information)) 0 7)))
  230.   (if (or (string=? vers "28sep90") (string=? vers "23feb90")
  231.       (string=? vers "01nov91"))
  232.       (begin
  233.     ;; GCD fails with 0 as argument
  234.     (define old-gcd gcd)
  235.     (set! gcd (lambda args
  236.             (apply old-gcd (remv! 0 args))))
  237.     
  238.     ;; STRING->SYMBOL doesn't allocate a new string
  239.     (set! string->symbol
  240.           (let ((fred string->symbol))
  241.         (lambda (a) (fred (string-append a)))))
  242.     
  243.     ;; NUMBER->STRING can generate a leading #?
  244.     (set! number->string
  245.           (let ((fred number->string))
  246.         (lambda (num . radix)
  247.           (let ((joe (apply fred num radix)))
  248.             (if (char=? #\# (string-ref joe 0))
  249.             (substring joe 2 (string-length joe))
  250.             joe)))))
  251.     
  252.     ;; Another bug is bad expansion of LETREC when the body starts with a
  253.     ;; DEFINE as shown by test.scm -- not fixed here.
  254.     )))
  255.  
  256. (define promise:force force)
  257.  
  258. ;;; (implementation-vicinity) should be defined to be the pathname of
  259. ;;; the directory where any auxillary files to your Scheme
  260. ;;; implementation reside.
  261.  
  262. (define in-vicinity string-append)
  263.  
  264. ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  265. ;;; return if exitting not supported.
  266. (define slib:exit (lambda args (exit)))
  267.  
  268. ;;; Here for backward compatability
  269. (define scheme-file-suffix
  270.   (let ((suffix (case (software-type)
  271.           ((NOSVE) "_scm")
  272.           (else ".scm"))))
  273.     (lambda () suffix)))
  274.  
  275. ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  276. ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
  277.  
  278. (define (slib:load-source f) (load (string-append f (scheme-file-suffix))))
  279.  
  280. ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  281. ;;; by compiling "foo.scm" if this implementation can compile files.
  282. ;;; See feature 'COMPILED.
  283.  
  284. (define slib:load-compiled load)
  285.  
  286. ;;; At this point SLIB:LOAD must be able to load SLIB files.
  287.  
  288. (define slib:load slib:load-source)
  289.  
  290. (slib:load (in-vicinity (library-vicinity) "require"))
  291. ; eof
  292.